home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-tables.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  5.0 KB  |  126 lines  |  [TEXT/ttxt]

  1. ; -*- mode:     CL -*- ------------------------------------------------- ;
  2. ; File:         zebu-tables.l
  3. ; Description:  Conversion to CL of the original Scheme program by (W M Wells)
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      31-Oct-90
  6. ; Modified:     Mon Apr 11 14:11:29 1994 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1990, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. ;;;             Copyright (C) 1989, by William M. Wells III
  18. ;;;                         All Rights Reserved
  19. ;;;     Permission is granted for unrestricted non-commercial use.
  20. (in-package "ZEBU")
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22. ;;;
  23. ;;; On the representation of parsing tables:
  24. ;;;
  25. ;;; Action function is an array, indexed by the state number,
  26. ;;; of functions of grammar symbols represented as osets of
  27. ;;; 3 element lists containing a g-symbol index, the character
  28. ;;; s, r, or a for shift reduce or accept, and an integer encoding the
  29. ;;; next state, or production index as appropriate.
  30. ;;;
  31. ;;; Goto for non-terminals will be represented by a parallel array
  32. ;;; of osets of pairs whose cars are g-symbol indices, and whose
  33. ;;; cdrs are state indices.
  34.  
  35. (defvar *action-array*)
  36. (defvar *goto-array*)
  37. (declaim (type vector *action-array* *goto-array*))
  38.  
  39. ;;; An oset order function for parse table entries.
  40. (defun integer-function-order-function (a b)
  41.   (integer-order-function (car (the cons a)) (car (the cons b))))
  42.  
  43. ;;; Build the description of the state machine which is the lr-parser.
  44. ;;; The *lr0-item-sets* correspond to the states of the parser machine.
  45.  
  46. (defun build-parse-tables (doing-lalr1)
  47.   (setf *action-array* (make-sequence 'vector *lr0-item-set-count*))
  48.   (setf *goto-array* (make-sequence 'vector *lr0-item-set-count*))
  49.   (dotimes (i *lr0-item-set-count*)
  50.     (setf (svref (the vector *action-array*) i)
  51.       (make-oset :order-fn #'integer-function-order-function))
  52.     (setf (svref (the vector *goto-array*) i)
  53.       (make-oset :order-fn #'integer-function-order-function)))
  54.   (oset-for-each
  55.    #'(lambda (item-set)
  56.        (oset-for-each
  57.     #'(lambda (goto-elt)         
  58.         ;; Car of goto-elt is g-sym, cdr is item-set.
  59.         (if (g-symbol-non-terminal? (car goto-elt))
  60.         (oset-insert! (cons (g-symbol-index (car goto-elt))
  61.                     (item-set-index (cdr goto-elt)))
  62.                   (svref (the vector *goto-array*)
  63.                     (item-set-index item-set)))
  64.           (parse-table-insert! (g-symbol-index (car goto-elt))
  65.                    :s
  66.                    (item-set-index (cdr goto-elt))
  67.                    item-set)))
  68.     (item-set-goto-map item-set))
  69.        (oset-for-each
  70.     #'(lambda (closure-item)
  71.         ;; Could these be kernel items?
  72.         (if (dot-at-right-end? closure-item)
  73.         (let* ((closure-item-production (item-production closure-item))
  74.                (lhs-closure-item-production (lhs closure-item-production)))
  75.           (if (eq *augmented-start-g-symbol* lhs-closure-item-production)
  76.               (parse-table-insert! (g-symbol-index *the-end-g-symbol*)
  77.                        :a 0 item-set) ; accept, bogus 0
  78.             (oset-for-each
  79.              #'(lambda (gs)
  80.              (parse-table-insert!
  81.               (g-symbol-index gs)
  82.               :r
  83.               (production-index closure-item-production)
  84.               item-set))
  85.              ;; Here is the only difference between slr and lalr1
  86.              ;; (in the table construction phase).
  87.              (if doing-lalr1
  88.              (item-look-aheads closure-item)
  89.                (g-symbol-follow-set lhs-closure-item-production)))))))
  90.     (item-set-get-closure! item-set))
  91.        )
  92.    *lr0-item-sets*))
  93.  
  94.  
  95. ;;; An auxillary function for adding an entry to a parse table.
  96. ;;; A simple feature allows the system to be used with some 
  97. ;;; ambiguous grammars:  if the variable *allow-conflicts* it true,
  98. ;;; then when a conflict arises at table construction time, simply
  99. ;;; prefer the action which is already in the tables.  
  100. ;;; This feature works for the "dangling else" problem.
  101.  
  102. (defvar *allow-conflicts* t)
  103. (declaim (special *warn-conflicts*))
  104.  
  105. (defun parse-table-insert! (g-sym-index action-key index item-set)
  106.   (let ((to-insert (list g-sym-index action-key index)))
  107.     (multiple-value-bind (inserted? the-item)    
  108.     (oset-insert-2! to-insert
  109.             (svref *action-array* (item-set-index item-set)))
  110.       (unless inserted?
  111.     (when *warn-conflicts*
  112.       (warn "ACTION CONFLICT!!!-- state: ~S~%old entry: ~S  new entry: ~S~%~
  113.                  Continuing to build tables despite conflicts.~%~
  114.                  Will prefer old entry: ~S"
  115.         (item-set-index item-set) the-item to-insert the-item))
  116.     (unless *allow-conflicts* (error "ACTION CONFLICT"))))))
  117.  
  118. (declaim (inline get-print-name))
  119. (defun get-print-name (index)
  120.   (g-symbol-name (svref (the vector *symbol-array*) index)))
  121.  
  122.  
  123. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  124. ;;                               End of zebu-tables.l
  125. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  126.